home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmpenv.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
23KB
|
572 lines
;;; CMPENV Environments of the Compiler.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defvar *safe-compile* nil)
(defvar *compiler-check-args* nil)
(defvar *compiler-push-events* nil)
(defvar *speed* 3)
(defvar *space* 0)
;;; Only these flags are set by the user.
;;; If *safe-compile* is ON, some kind of run-time checks are not
;;; included in the compiled code. The default value is OFF.
(defun init-env ()
(setq *next-cvar* 0)
(setq *next-cmacro* 0)
(setq *next-vv* -1)
(setq *next-cfun* 0)
(setq *last-label* 0)
(setq *objects* nil)
(setq *constants* nil)
(setq *local-funs* nil)
(setq *global-funs* nil)
(setq *global-entries* nil)
(setq *undefined-vars* nil)
(setq *reservations* nil)
(setq *closures* nil)
(setq *top-level-forms* nil)
(setq *compile-time-too* *eval-when-compile*)
(setq *non-package-operation* nil)
(setq *function-declarations* nil)
(setq *inline-functions* nil)
(setq *inline-blocks* 0)
(setq *notinline* nil)
)
(defvar *next-cvar* 0)
(defvar *next-cmacro* 0)
(defvar *next-vv* -1)
(defvar *next-cfun* 0)
;;; *next-cvar* holds the last cvar number used.
;;; *next-cmacro* holds the last cmacro number used.
;;; *next-vv* holds the last VV index used.
;;; *next-cfun* holds the last cfun used.
(defmacro next-cfun () '(incf *next-cfun*))
(defun add-symbol (symbol)
(let ((x (assoc symbol *objects*)))
(cond (x (cadr x))
(t (incf *next-vv*)
(push (list symbol *next-vv*) *objects*)
(wt-data symbol)
*next-vv*))))
(defun add-object (object &aux x)
;;; Used only during Pass 1.
(cond ((si:contains-sharp-comma object)
;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
;;; contains a sharp comma OR a structure.
(incf *next-vv*)
(push *next-vv* *sharp-commas*)
(wt-data (prin1-to-string object))
*next-vv*)
((setq x (assoc object *objects*))
(cadr x))
(t (incf *next-vv*)
(push (list object *next-vv*) *objects*)
(wt-data object)
*next-vv*)))
(defun add-constant (symbol &aux x)
;;; Used only during Pass 1.
(cond ((setq x (assoc symbol *constants*))
(cadr x))
(t (incf *next-vv*)
(push *next-vv* *sharp-commas*)
(wt-data (prin1-to-string (cons 'si:|#,| symbol)))
(push (list symbol *next-vv*) *constants*)
*next-vv*)))
(defmacro next-cvar () '(incf *next-cvar*))
(defmacro next-cmacro () '(incf *next-cmacro*))
;;; Tail recursion information.
(defvar *do-tail-recursion* t)
(defvar *tail-recursion-info* nil)
;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
;;; If possible, *tail-recursion-info* holds
;;; ( fname required-arg .... required-arg ),
;;; where each required-arg is a var-object.
(defvar *function-declarations* nil)
;;; *function-declarations* holds :
;;; (... ( { function-name | fun-object } arg-types return-type ) ...)
;;; Function declarations for global functions are ASSOCed by function names,
;;; whereas those for local functions are ASSOCed by function objects.
;;;
;;; The valid argment type declaration is:
;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
;;; though &optional, &rest, and &key return types are simply ignored.
(defun function-arg-types (arg-types &aux (types nil))
(do ((al arg-types (cdr al)))
((or (endp al)
(member (car al) '(&optional &rest &key)))
(reverse types))
(declare (object al))
(push (type-filter (car al)) types)))
;;; The valid return type declaration is:
;;; (( VALUES {type}* )) or ( {type}* ).
(defun function-return-type (return-types)
(cond ((endp return-types) t)
((and (consp (car return-types))
(eq (caar return-types) 'values))
(cond ((not (endp (cdr return-types)))
(warn "The function return types ~s is illegal." return-types)
t)
((or (endp (cdar return-types))
(member (cadar return-types) '(&optional &rest &key)))
t)
(t (type-filter (cadar return-types)))))
(t (type-filter (car return-types)))))
(defun add-function-proclamation (fname arg-types return-types)
(cond ((symbolp fname)
(si:putprop fname (function-arg-types arg-types)
'proclaimed-arg-types)
(si:putprop fname (function-return-type return-types)
'proclaimed-return-type)
;;; A non-local function may have local entry only if it returns
;;; a single value.
(if (and (not (endp return-types))
(endp (cdr return-types))
(not (and (consp (car return-types))
(eq (caar return-types) 'values)
(or (endp (cdar return-types))
(not (endp (cddar return-types)))))))
(si:putprop fname t 'proclaimed-function)
(remprop fname 'proclaimed-function)))
(t (warn "The function name ~s is not a symbol." fname))))
(defun add-function-declaration (fname arg-types return-types)
(cond ((symbolp fname)
(push (list (sch-local-fun fname)
(function-arg-types arg-types)
(function-return-type return-types))
*function-declarations*))
(t (warn "The function name ~s is not a symbol." fname))))
(defun get-arg-types (fname &aux x)
(if (setq x (assoc fname *function-declarations*))
(cadr x)
(get fname 'proclaimed-arg-types)))
(defun get-return-type (fname)
(let* ((x (assoc fname *function-declarations*))
(type1 (if x (caddr x) (get fname 'proclaimed-return-type))))
(cond (type1
(let ((type (get fname 'return-type)))
(cond (type
(cond ((setq type (type-and type type1)) type)
(t
(cmpwarn
"The return type of ~s was badly declared."
fname))))
(t type1))))
(t (get fname 'return-type)))
))
(defun get-local-arg-types (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
(cadr x)
nil))
(defun get-local-return-type (fun &aux x)
(if (setq x (assoc fun *function-declarations*))
(caddr x)
nil))
(defvar *sup-used* nil)
(defvar *base-used* nil)
(defun reset-top ()
(wt "vs_top=sup;")
(setq *sup-used* t))
(defmacro base-used () '(setq *base-used* t))
;;; Proclamation and declaration handling.
(defvar *alien-declarations* nil)
(defvar *notinline* nil)
(defun inline-possible (fname)
(not (or *compiler-push-events*
(member fname *notinline*)
(get fname 'cmp-notinline))))
(defun proclaim (decl)
(case (car decl)
(special
(dolist** (var (cdr decl))
(if (symbolp var)
(si:*make-special var)
(warn "The variable name ~s is not a symbol." var))))
(optimize
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (cadr x)))
(not (<= 0 (cadr x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(safety (setq *compiler-check-args* (>= (cadr x) 1))
(setq *safe-compile* (>= (cadr x) 2))
(setq *compiler-push-events* (>= (cadr x) 3)))
(space (setq *space* (cadr x)))
(speed (setq *speed* (cadr x)))
(compilation-speed (setq *speed* (- 3 (cadr x))))
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
(type
(if (consp (cdr decl))
(proclaim-var (cadr decl) (cddr decl))
(warn "The type declaration ~s is illegal." decl)))
((fixnum character short-float long-float)
(proclaim-var (car decl) (cdr decl)))
(ftype
(if (or (endp (cdr decl))
(not (consp (cadr decl)))
(not (eq (caadr decl) 'function))
(endp (cdadr decl)))
(warn "The function declaration ~s is illegal." decl)
(dolist** (fname (cddr decl))
(add-function-proclamation fname (cadadr decl) (cddadr decl)))))
(function
(if (or (endp (cdr decl)) (endp (cddr decl)))
(warn "The function declaration ~s is illegal." decl)
(add-function-proclamation (cadr decl) (caddr decl) (cdddr decl))))
(inline
(dolist** (fun (cdr decl))
(if (symbolp fun)
(remprop fun 'cmp-notinline)
(warn "The function name ~s is not a symbol." fun))))
(notinline
(dolist** (fun (cdr decl))
(if (symbolp fun)
(si:putprop fun t 'cmp-notinline)
(warn "The function name ~s is not a symbol." fun))))
((object ignore)
(dolist** (var (cdr decl))
(unless (symbolp var)
(warn "The variable name ~s is not a symbol." var))))
(declaration
(dolist** (x (cdr decl))
(if (symbolp x)
(unless (member x *alien-declarations*)
(push x *alien-declarations*))
(warn "The declaration specifier ~s is not a symbol." x))))
((array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float hash-table integer keyword list
long-float nil null number package pathname random-state ratio rational
readtable sequence short-float simple-array simple-bit-vector
simple-string simple-vector single-float standard-char stream string
string-char symbol t vector signed-byte unsigned-byte)
(proclaim-var (car decl) (cdr decl)))
(otherwise
(unless (member (car decl) *alien-declarations*)
(warn "The declaration specifier ~s is unknown." (car decl))))
)
nil
)
(defun proclaim-var (type vl)
(setq type (type-filter type))
(dolist** (var vl)
(cond ((symbolp var)
(let ((type1 (get var 'cmp-type))
(v (sch-global var)))
(setq type1 (if type1 (type-and type1 type) type))
(when v (setq type1 (type-and type1 (var-type v))))
(when (null type1) (warn
"Inconsistent type declaration was found for the variable ~s."
var))
(si:putprop var type1 'cmp-type)
(when v (setf (var-type v) type1))))
(t
(warn "The variable name ~s is not a symbol." var)))))
(defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
doc form)
(loop
(when (endp body) (return))
(setq form (cmp-macroexpand (car body)))
(cond
((stringp form)
(when (or (null doc-p) (endp (cdr body)) doc) (return))
(setq doc form))
((and (consp form) (eq (car form) 'declare))
(dolist** (decl (cdr form))
(cmpck (or (not (consp decl)) (not (symbolp (car decl))))
"The declaration ~s is illegal." decl)
(case (car decl)
(special
(dolist** (var (cdr decl))
(cmpck (not (symbolp var))
"The special declaration ~s contains a non-symbol ~s."
decl var)
(push var ss)))
(ignore
(dolist** (var (cdr decl))
(cmpck (not (symbolp var))
"The ignore declaration ~s contains a non-symbol ~s."
decl var)
(push var is)))
(type
(cmpck (endp (cdr decl))
"The type declaration ~s is illegal." decl)
(let ((type (type-filter (cadr decl))))
(when type
(dolist** (var (cddr decl))
(cmpck (not (symbolp var))
"The type declaration ~s contains a non-symbol ~s."
decl var)
(push (cons var type) ts)))))
(object
(dolist** (var (cdr decl))
(cmpck (not (symbolp var))
"The object declaration ~s contains a non-symbol ~s."
decl var)
(push (cons var 'object) ts)))
((fixnum character double-float short-float array atom bignum bit
bit-vector common compiled-function complex cons float hash-table
integer keyword list long-float nil null number package pathname
random-state ratio rational readtable sequence simple-array
simple-bit-vector simple-string simple-vector single-float
standard-char stream string string-char symbol t vector
signed-byte unsigned-byte)
(let ((type (type-filter (car decl))))
(when type
(dolist** (var (cdr decl))
(cmpck (not (symbolp var))
"The type declaration ~s contains a non-symbol ~s."
decl var)
(push (cons var type) ts)))))
(otherwise (push decl others))
)))
(t (return)))
(pop body)
)
(values body ss ts is others doc)
)
(defun c1decl-body (decls body &aux (dl nil))
(if (null decls)
(c1progn body)
(let ((*function-declarations* *function-declarations*)
(*alien-declarations* *alien-declarations*)
(*notinline* *notinline*)
(*space* *space*))
(dolist** (decl decls dl)
(case (car decl)
(optimize
(dolist (x (cdr decl))
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (cadr x)))
(not (<= 0 (cadr x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(safety (push (list 'safety (cadr x)) dl))
(space (setq *space* (cadr x))
(push (list 'space (cadr x)) dl))
((speed compilation-speed))
(t (warn "The OPTIMIZE quality ~s is unknown."
(car x)))))))
(ftype
(if (or (endp (cdr decl))
(not (consp (cadr decl)))
(not (eq (caadr decl) 'function))
(endp (cdadr decl)))
(warn "The function declaration ~s is illegal." decl)
(dolist** (fname (cddr decl))
(add-function-declaration
fname (cadadr decl) (cddadr decl)))))
(function
(if (or (endp (cdr decl))
(endp (cddr decl))
(not (symbolp (cadr decl))))
(warn "The function declaration ~s is illegal." decl)
(add-function-declaration
(cadr decl) (caddr decl) (cdddr decl))))
(inline
(dolist** (fun (cdr decl))
(if (symbolp fun)
(progn (push (list 'inline fun) dl)
(setq *notinline* (remove fun *notinline*)))
(warn "The function name ~s is not a symbol." fun))))
(notinline
(dolist** (fun (cdr decl))
(if (symbolp fun)
(progn (push (list 'notinline fun) dl)
(push fun *notinline*))
(warn "The function name ~s is not a symbol." fun))))
(declaration
(dolist** (x (cdr decl))
(if (symbolp x)
(unless (member x *alien-declarations*)
(push x *alien-declarations*))
(warn "The declaration specifier ~s is not a symbol."
x))))
(otherwise
(unless (member (car decl) *alien-declarations*)
(warn "The declaration specifier ~s is unknown."
(car decl))))
))
(setq body (c1progn body))
(list 'decl-body (cadr body) dl body)
)
)
)
(si:putprop 'decl-body 'c2decl-body 'c2)
(defun c2decl-body (decls body)
(let ((*compiler-check-args* *compiler-check-args*)
(*safe-compile* *safe-compile*)
(*compiler-push-events* *compiler-push-events*)
(*notinline* *notinline*)
(*space* *space*))
(dolist** (decl decls)
(case (car decl)
(safety
(let ((level (cadr decl)))
(declare (fixnum level))
(setq *compiler-check-args* (>= level 1)
*safe-compile* (>= level 2)
*compiler-push-events* (>= level 3))))
(space (setq *space* (cadr decl)))
(notinline (push (cadr decl) *notinline*))
(inline
(setq *notinline* (remove (cadr decl) *notinline*)))
(otherwise (baboon))))
(c2expr body))
)
(defun check-vdecl (vnames ts is)
(dolist** (x ts)
(unless (member (car x) vnames)
(cmpwarn "Type declaration was found for not bound variable ~s."
(car x))))
(dolist** (x is)
(unless (member x vnames)
(cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
)
(defun proclamation (decl)
(case (car decl)
(special
(dolist** (var (cdr decl) t)
(if (symbolp var)
(unless (si:specialp var) (return nil))
(warn "The variable name ~s is not a symbol." var))))
(optimize
(dolist (x (cdr decl) t)
(when (symbolp x) (setq x (list x 3)))
(if (or (not (consp x))
(not (consp (cdr x)))
(not (numberp (cadr x)))
(not (<= 0 (cadr x) 3)))
(warn "The OPTIMIZE proclamation ~s is illegal." x)
(case (car x)
(safety
(unless (= (cadr x)
(cond ((null *compiler-check-args*) 0)
((null *safe-compile*) 1)
((null *compiler-push-events*) 2)
(t 3)))
(return nil)))
(space (unless (= (cadr x) *space*) (return nil)))
(speed (unless (= (cadr x) *speed*) (return nil)))
(compilation-speed
(unless (= (- 3 (cadr x)) *speed*) (return nil)))
(t (warn "The OPTIMIZE quality ~s is unknown."
(car x)))))))
(type
(if (consp (cdr decl))
(let ((type (type-filter (cadr decl)))
x)
(dolist** (var (cddr decl) t)
(if (symbolp var)
(unless (and (setq x (get var 'cmp-type))
(equal x type))
(return nil))
(warn "The variable name ~s is not a symbol." var))))
(warn "The type declaration ~s is illegal." decl)))
((fixnum character short-float long-float)
(let ((type (type-filter (car decl)))
x)
(dolist** (var (cdr decl) t)
(if (symbolp var)
(unless (and (setq x (get var 'cmp-type)) (equal x type))
(return nil))
(warn "The variable name ~s is not a symbol." var)))))
(ftype
(if (or (endp (cdr decl))
(not (consp (cadr decl)))
(not (eq (caadr decl) 'function))
(endp (cdadr decl)))
(warn "The function declaration ~s is illegal." decl)
(dolist** (fname (cddr decl) t)
(unless (and (get fname 'proclaimed-function)
(equal (function-arg-types (cadadr decl))
(get fname 'proclaimed-arg-types))
(equal (function-return-type (cddadr decl))
(get fname 'proclaimed-return-type)))
(return nil)))))
(function
(if (or (endp (cdr decl)) (endp (cddr decl)))
(warn "The function declaration ~s is illegal." decl)
(and (get (cadr decl) 'proclaimed-function)
(equal (function-arg-types (caddr decl))
(get (cadr decl) 'proclaimed-arg-types))
(equal (function-return-type (cdddr decl))
(get (cadr decl) 'proclaimed-return-type)))))
(inline (dolist** (fun (cdr decl) t)
(if (symbolp fun)
(when (get fun 'cmp-notinline) (return nil))
(warn "The function name ~s is not a symbol." fun))))
(notinline (dolist** (fun (cdr decl) t)
(if (symbolp fun)
(unless (get fun 'cmp-notinline) (return nil))
(warn "The function name ~s is not a symbol." fun))))
((object ignore)
(dolist** (var (cdr decl) t)
(unless (symbolp var)
(warn "The variable name ~s is not a symbol." var))))
(declaration (dolist** (x (cdr decl) t)
(if (symbolp x)
(unless (member x *alien-declarations*) (return nil))
(warn "The declaration specifier ~s is not a symbol."
x))))
((array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float hash-table integer keyword list
long-float nil null number package pathname random-state ratio rational
readtable sequence short-float simple-array simple-bit-vector
simple-string simple-vector single-float standard-char stream string
string-char symbol t vector signed-byte unsigned-byte)
(let ((type (type-filter (car decl))))
(dolist** (var (cdr decl) t)
(if (symbolp var)
(unless (equal (get var 'cmp-type) type) (return nil))
(warn "The variable name ~s is not a symbol." var)))))
(otherwise
(unless (member (car decl) *alien-declarations*)
(warn "The declaration specifier ~s is unknown." (car decl))))
)
)